Public Function AddHatch(ByRef objList() As AcadEntity, ByVal patType As Integer, ByVal parName As String, ByVal associativity As Boolean) As AcadHatch On Error GoTo errHandle Dim objHatch As AcadHatch Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, patName, associativity, acHatchObject) objHatch.AppendOuterLoop (objList) objHatch.Evaluate ThisDrawing.Regen True Set AddHatch = objHatch Exit Function errHandle: If Err.Number = -2145386493 Then MsgBox "填充定义边界未闭合", vbCritical End If Err.Clear End Function Public Function AddHatchGC(ByRef objList() As AcadEntity, ByVal parType As Integer, ByVal parName As String, ByVal associativity As Double, ByVal color1 As AcadAcCmColor, ByVal color2 As AcadAcCmColor) As AcadHatch On Error GoTo errHandle Dim objHatch As AcadHatch Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, patName, True, acGradientObject) objHatch.GradientColor1 = color1 objHatch.GradientColor2 = color2 objHatch.AppendOuterLoop (objList) objHatch.Evaluate ThisDrawing.Regen True Set AddHatchGC = objHatch Exit Function errHandle: If Err.Number = -2145386493 Then MsgBox "填充定义边界未闭合", vbCritical End If Err.Clear End Function Public Function AddHatchPt(ByRef ptArr() As Double, ByVal parType As Integer, ByVal patName As String, ByVal associativity As Boolean) As AcadHatch Dim objPline As AcadLWPolyline If (UBound(ptArr) + 1) Mod 2 Then MsgBox "数组元素必须为偶数" Exit Function End If Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr) objPline.Closed = True Dim objList(0) As AcadEntity Set objList(0) = objPline Set AddHatchPt = AddHatch(objList, patType, patName, associativity) End Function Public Function AddHatchTC(ByRef objList() As AcadEntity, ByVal patName As Integer, ByVal associativity As Boolean, ByVal color As AcadAcCmColor) As AcadHatch On Error GoTo errHandle Dim objHatch As AcadHatch Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, "LINEAR", True, acGradientObject) objHatch.GradientColor1 = color objHatch.GradientColor2 = color objHatch.AppendOuterLoop (objList) objHatch.Evaluate ThisDrawing.Regen True Set AddHatchTC = objHatch Exit Function errHandle: If Err.Number = -2145386493 Then MsgBox "填充边界闭合！", vbCritical End If Err.Clear End Function Public Function MoveEntity(ByVal objEntity As AcadEntity, ByVal x As Double, ByVal y As Double, Optional z As Double = 0) Dim ptBase(2) As Double Dim ptDest(2) As Double ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0 ptDest(0) = x: ptDest(1) = y: ptDest(2) = z objEntity.Move ptBase, ptDest End Function Public Sub TestHatch() Dim objList(1) As AcadEntity Dim pt(0 To 2) As Double Dim objArc As AcadArc Dim objLine As AcadLine Dim objCircle As AcadCircle pt(0) = 100: pt(1) = 100: pt(2) = 0 Set objArc = ThisDrawing.ModelSpace.AddArc(pt, 30, 0, 2.5) Set objLine = ThisDrawing.ModelSpace.AddLine(objArc.StartPoint, objArc.EndPoint) Set objList(0) = objArc Set objList(1) = objLine AddHatch objList, 0, "ANSI31", True Dim color As AcadAcCmColor Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16") Call color.SetRGB(0, 255, 127) Set objList(0) = objArc.Copy MoveEntity objList(0), 0, 30 Set objList(1) = objLine.Copy MoveEntity objList(1), 0, 30 AddHatchTC objList, 0, True, color Dim color2 As AcadAcCmColor Set color2 = AcadApplication.GetInterfaceObject("autocad.accmcolor.16") color2.SetRGB 255, 0, 25 Set objList(0) = objArc.Copy MoveEntity objList(0), 80, 30 Set objList(1) = objLine.Copy MoveEntity objList(1), 80, 30 AddHatchTC objList, 0, True, color AddHatchGC objList, 0, "LINEAR", True, color, color2 Dim ptArr(7) As Double ptArr(0) = 160: ptArr(1) = 90: ptArr(2) = 200: ptArr(3) = 90 ptArr(4) = 200: ptArr(5) = 120: ptArr(6) = 160: ptArr(7) = 120 AddHatchPt ptArr, o, "ANSI31", True End Sub